home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / alphaCommands.tcl < prev    next >
Encoding:
Text File  |  1998-12-05  |  6.2 KB  |  250 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "alphaCommands.tcl"
  6.  #                                    created: 03/18/1998 {01:13:44 AM} 
  7.  #                                last update: 5/12/1998 {11:24:32 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: vince@biosgroup.com
  10.  #    mail: Bios Group
  11.  #          617 Paseo de Peralta, Santa Fe, NM 87501
  12.  #     www: http://www.biosgroup.com/
  13.  #  
  14.  # Copyright (c) 1998 Vince Darley
  15.  # 
  16.  # All rights reserved.
  17.  # 
  18.  # See the file "license.terms" for information on usage and redistribution of
  19.  # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20.  #  
  21.  #  Description: 
  22.  # 
  23.  #   Mostly procedures which would really help Alpha if they were
  24.  #   hard-coded.  Some other procedures for convenience are here too.
  25.  #  History
  26.  # 
  27.  #  modified by  rev reason
  28.  #  -------- --- --- -----------
  29.  #  03/18/19 VMD 1.0 original
  30.  # ###################################################################
  31.  ##
  32.  
  33. if {${alpha::platform} != "alpha"} {
  34.     alertnote "Shouldn't load this code"
  35.     return
  36. }
  37.  
  38. namespace eval tmark {}
  39.  
  40. ## 
  41.  # -------------------------------------------------------------------------
  42.  # 
  43.  # "tmark::getPos" --
  44.  # 
  45.  #  This procedure is pretty slow, due to limitations in Alpha.  Hopefully
  46.  #  one day we'll have a hard-wired quick version.  It also works around
  47.  #  a bug in which Alpha tells us that windows which aren't files (e.g.
  48.  #  just created with 'new -n') are located in Alpha's 'pwd' directory.
  49.  #  
  50.  #  The stupid thing is that Alpha knows exactly where each stop is, but
  51.  #  it won't tell us!  'gotoTMark $m' goes to exactly the position we
  52.  #  want, but we can't find it out some other way.
  53.  # -------------------------------------------------------------------------
  54.  ##
  55. if {[info tclversion] < 8.0} {
  56. proc tmark::getPos {m {f ""}} {
  57.     if {$f == ""} {
  58.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  59.     }
  60.     if {[file exists $f]} {
  61.     if {[regexp "\{$m \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  62.         return $where
  63.     }
  64.     } else {
  65.     if {[regexp "\{$m \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}" [getTMarks] "" where]} {
  66.         return $where
  67.     }
  68.     }
  69.     error "No such mark"
  70. }
  71. } else {
  72.     proc tmark::getPos {m {f ""}} { 
  73.     if {$f == ""} {
  74.         return [lindex [getPosOfTMark $m] 0] 
  75.     } else {
  76.         return [lindex [getPosOfTMark -w $f $m] 0] 
  77.     }
  78.     }
  79.  
  80. }
  81. if {[info tclversion] < 8.0} {
  82.     proc tmark::getRange {m {f ""}} {
  83.     if {$f == ""} {
  84.         regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  85.     }
  86.     if {[file exists $f]} {
  87.         if {[regexp "\{$m \{[quote::Regfind $f]\} (\[0-9\]+ \[0-9\]+)\}" [getTMarks] "" where]} {
  88.         return $where
  89.         }
  90.     } else {
  91.         if {[regexp "\{$m \{[quote::Regfind [pwd]$f]\} (\[0-9\]+ \[0-9\]+)\}" [getTMarks] "" where]} {
  92.         return $where
  93.         }
  94.     }
  95.     error "No such mark"
  96.     }
  97. } else {
  98.     proc tmark::getRange {m {f ""}} { 
  99.     if {$f == ""} {
  100.         return [getPosOfTMark $m]
  101.     } else {
  102.         return [getPosOfTMark -w $f $m]
  103.     }
  104.     }
  105.  
  106. }
  107. namespace eval mark {}
  108. if {[info tclversion] < 8.0} {
  109.     proc mark::getRange {m {f ""}} {
  110.     if {$f == ""} {
  111.         regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  112.     }
  113.     if {[file exists $f]} {
  114.         if {[regexp "\{$m \{[quote::Regfind $f]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  115.         return $where
  116.         }
  117.     } else {
  118.         if {[regexp "\{$m \{[quote::Regfind [pwd]$f]\} (\[0-9\]+ \[0-9\]+ \[0-9\]+)" [getNamedMarks -w $f] "" where]} {
  119.         return $where
  120.         }
  121.     }
  122.     error "No such mark"
  123.     }
  124. } else {
  125.     proc mark::getRange {m {f ""}} { 
  126.     if {$f == ""} {
  127.         return [getPosOfMark $m]
  128.     } else {
  129.         return [getPosOfMark -w $f $m]
  130.     }
  131.     }
  132.  
  133. }
  134.  
  135. ## 
  136.  # -------------------------------------------------------------------------
  137.  # 
  138.  # "tmark::getPositions" --
  139.  # 
  140.  #  For speed you can ask for a bunch of positions at once.
  141.  # -------------------------------------------------------------------------
  142.  ##
  143. if {[info tclversion] < 8.0} {
  144.     proc tmark::getPositions {mm} {
  145.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  146.     if {[file exists $f]} {
  147.     set reg " \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}"
  148.     } else {
  149.     set reg " \{[quote::Regfind [pwd]$f]\} (\[0-9\]+) \[0-9\]+\}"
  150.     }
  151.     set marks [getTMarks]
  152.     set reg " \{[quote::Regfind $f]\} (\[0-9\]+) \[0-9\]+\}"
  153.     foreach m $mm {
  154.     if {[regexp "\{$m$reg" $marks "" where]} {
  155.         lappend res $where
  156.     } else {
  157.         error "No such mark"
  158.     }
  159.     }
  160.     return $res
  161. }
  162. } else {
  163.     proc tmark::getPositions {mm} {
  164.     foreach m $mm {
  165.         lappend res [lindex [getPosOfTMark $m] 0]
  166.     }
  167.     return $res
  168.     }
  169. }
  170.  
  171. if {[info tclversion] < 8.0} {
  172.  
  173. proc tmark::isAt {p} {
  174.     regexp {(.*) <[0-9]+>$} [set f [win::Current]] "" f
  175.     if {[file exists $f]} {
  176.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind $f]\} $p $p\}" [getTMarks] "" which]} {
  177.         return $which
  178.     }
  179.     } else {
  180.     if {[regexp "\{(stop\[0-9\]+:\[0-9\]+) \{[quote::Regfind [pwd]$f]\} $p $p\}" [getTMarks] "" which]} {
  181.         return $which
  182.     }
  183.     }
  184.     return ""
  185. }
  186.  
  187. } else {
  188.     proc tmark::isAt {p} { return [isTMarkAt $p] }
  189. }
  190.  
  191. # Thanks to Johan Linde:
  192. proc refresh {{w ""}} {
  193.     if {$w == ""} {
  194.     eval sizeWin [lrange [getGeometry] 2 end]
  195.     } else {
  196.     eval sizeWin [list $w] [lrange [getGeometry $w] 2 end]
  197.     }
  198. }
  199.  
  200.  
  201. namespace eval text {}
  202.  
  203. proc text::hyper {from to hyper} {
  204.     text::color $from $to 15 $hyper
  205. }
  206.  
  207. proc text::color {from to colour {hyper ""}} {
  208.     if {$colour > 7} {
  209.     if {$colour == 15} {
  210.         insertColorEscape $from $colour $hyper
  211.     } else {
  212.         insertColorEscape $from $colour
  213.     }
  214.     insertColorEscape $to 12
  215.     } else {
  216.     insertColorEscape $from $colour
  217.     insertColorEscape $to 0
  218.     }
  219. }
  220.  
  221. namespace eval status {}
  222.  
  223. proc status::prompt {prompt {func ""} {type "key"}} {
  224.     global status::proc status::add
  225.     set status::proc $func
  226.     set status::add $type
  227.     return [uplevel [list statusPrompt $prompt status::helper]]
  228. }
  229.  
  230. proc status::helper {args} {
  231.     global status::add status::proc
  232.     switch -- ${status::add} {
  233.     "modifiers" -
  234.     "anything" {
  235.         lappend args [getModifiers]
  236.     } 
  237.     }
  238.     return [uplevel ${status::proc} $args]
  239. }
  240.  
  241. namespace eval pos {}
  242.  
  243. proc pos::compare {args} {uplevel expr $args}
  244. proc pos::math {args} {uplevel expr $args}
  245. proc minPos {} { return 0 }
  246.  
  247.  
  248.  
  249.  
  250.